{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeFamilies,
  UndecidableInstances #-}

module LLBasics where

import Common

import TopLevelFunctions

import qualified Data.IntMap as IM; import Data.IntMap (IntMap)

import Control.Arrow (second)
import Control.Monad (liftM, ap)
import Control.Applicative (Applicative(pure, (<*>)))





type Rename = (Int, IntMap Int)

lookupRN :: Rename -> Int -> Occ
lookupRN rn@(locals, m) i
  | i < locals = Occ $ Right i
  | otherwise = maybe err (Occ . Left) $ IM.lookup (i - locals) m
  where err = error $ "LLBasics.lookupRN: unresolved variable: " ++ show (i, rn)



newtype Mnd_LL a =
  Mnd_LL {runMnd_LL :: ([Type], Rename, Int) -> (a, [FunDec])}

instance Functor Mnd_LL where fmap = liftM
instance Applicative Mnd_LL where pure = return; (<*>) = ap
instance Monad Mnd_LL where
  return a = Mnd_LL $ \_ -> (a, [])
  m >>= k = Mnd_LL $ \e@(tys, rn, s) -> case runMnd_LL m e of
    ~(a, w) -> second (w ++) $ runMnd_LL (k a) (tys, rn, length w + s)

ask :: Mnd_LL ([Type], Rename)
ask = Mnd_LL $ \ ~(x, y, _) -> ((x, y), [])

local :: (([Type], Rename) -> ([Type], Rename)) -> Mnd_LL a -> Mnd_LL a
local f (Mnd_LL g) = Mnd_LL $ \ ~(x, y, z) -> case f (x, y) of
  ~(x', y') -> g (x', y', z)

numEmissions :: Mnd_LL Int
numEmissions = Mnd_LL $ \ ~(_, _, s) -> (s, [])

emit :: FunDec -> Mnd_LL ()
emit w = Mnd_LL $ \_ -> ((), [w])
